Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Pascal/Libraries/MCC Utils/MCCursor.p

Text File | 1994-05-04 | 8.6 KB | 243 lines | [TEXT/PJMM]

{This document is formated in monaco 9 pt                                          }
{                                                                                  }
{LEGAL STUFF                                                                       }
{                                                                                  }
{Copyright © 1994 by University of Melbourne. All Rights Reserved. This work is    }
{provided "as is" and without any express or implied warranties, including,        }
{without limitation, the implied warranties of merchantability and fitness         }
{for a particular purpose.                                                         }
{                                                                                  }
{University of Melbourne is not responsible for the consequences of the use of this}
{work, regardless of the cause. You may use this work in a public domain,          }
{freeware, or shareware product with no restrictions, as long as you include       }
{the following notice in your product's about box or splash screen:                }
{  "Portions Copyright © 1994 by University of Melbourne".                         }
{If you use more than 50 lines of this work, please credit the author also:        }
{  "Portions by Michael Cutter"                                                    }
{Public domain is defined as something that you release to the public, without     }
{copyright and without restrictions on use. Freeware is a copyrighted work,        }
{for which you charge no money. Shareware is a copyrighted work for which you      }
{charge a fee if the user decides to keep it. If you intend to use this work       }
{in a commercial product, please contact us.                                       }
{                                                                                  }
{                                                                                  }
{OTHER STUFF                                                                       }
{                                                                                  }
{AUTHOR:                                                                           }
{ Michael Trevor Cutter                                                            }
{                                                                                  }
{CONTACT:                                                                          }
{  Internet:                                                                       }
{    [e-mail] (Preferred)                                          }
{  Snail Mail:                                                                     }
{    Dept of Architecture & Building                                               }
{    University of Melbourne                                                       }
{    Parkville VIC 3052                                                            }
{    AUSTRALIA                                                                     }
{                                                                                  }
{PERSONAL STUFF                                                                    }
{  I'd really appreciate it if you'd let me know what you're using my code         }
{  in, (send me email or a postcard). Please report any bugs or errors to me.      }
{                                                                                  }
{MODULE DESCRIPTION                                                                }
{This module provides general cursor utilities, and three functions for using      }
{colour animated cursors. This does not install a VBL task, instead you simply     }
{call the MCNextAnimCursor function whenever you want to move it on. This is much  }
{more user-friendly (IMHO) because it indicates actual processing.                 }

unit MCCursor;
interface

{like Hypercard's set cursor, but supports colour cursors}
    procedure MCSetCursor (resid: integer;
                                    releasecursor: Boolean);

{obvious, really}
    procedure MCWatchCursor;
    procedure MCIBeamCursor;
    procedure MCPlusCursor;
    procedure MCCrossCursor;
    procedure MCArrowCursor;

{To use colour animated cursors, provide an acur resource specifying the ids and}
{delay in order, and colour cursor resources with the matching ids as the b&w ones}
{Then, call  MCStartAnimCursor  (generally in the initialization sequence of your}
{program) with the acur id.}
{Then, at appropriate points in your program (busy loops etc), call  MCNextAnimCursor  }
{which will animate the cursor forward one step}

{for animated cursors}
{this procedure finds the acur resource specified,}
{and loads it into memory - note limitation of 64 cursors, but you can change}
{that by modifying the size of the array.}
    procedure MCStartAnimCursor (acurresid: integer);

{this procedure checks the cursor counter, and whether enough time}
{(as specified in the acur) has passed, and if so, gets the next}
{cursor (colour if available) and sets it}
    procedure MCNextAnimCursor;

{note - there are one or two simple functions, such as getting the current screen depth,}
{which are not provided}

implementation
    const
        kMCCurMaxCursors = 64;
    var
        gMCCurrHasColour: Boolean;
        gMCcurracurid: integer;
        gMCcurrcurindex: integer;
        gMCacurids: array[1..kMCCurMaxCursors] of integer;
        gMCcurscount: integer;
        MCcursLastTime: longint;
        MCcursCursorsOn: boolean;
        MCcursInterval: integer;

    function MCHasColourQD: Boolean;
        var
            myComputer: SysEnvRec;
            myErr: OSErr;
    begin
        myErr := SysEnvirons(1, myComputer);
        if ((myErr = noErr) and (myComputer.hasColorQD)) then
            MCHasColourQD := true
        else
            MCHasColourQD := false;
    end;

    procedure MCSetCursor;
        var
            curs: CursHandle;
            ccurs: CCrsrHandle;
    begin
        curs := nil;
        if gMCCurrHasColour then
            if (GetMainDevice^^.gdPMap^^.pixelsize > 2) then
                begin
                    ccurs := GetCCursor(resid);
                    if (ccurs <> nil) and (ResError = noErr) then
                        begin
                            SetCCursor(ccurs);
                            if releasecursor then
                                DisposeCCursor(ccurs);
                            exit(MCSetCursor);
                        end;
                end;
        curs := GetCursor(resid);
        if (curs <> nil) and (ResError = noErr) then
            begin
                hlock(handle(curs));
                SetCursor(curs^^);
                hunlock(handle(curs));
                if releasecursor then
                    ReleaseResource(handle(curs));
            end
        else
            InitCursor;
    end;

    procedure MCWatchCursor;
    begin
        SetCursor(GetCursor(watchCursor)^^);
    end;

    procedure MCIBeamCursor;
    begin
        SetCursor(GetCursor(iBeamCursor)^^);
    end;

    procedure MCPlusCursor;
    begin
        SetCursor(GetCursor(plusCursor)^^);
    end;

    procedure MCCrossCursor;
    begin
        SetCursor(GetCursor(crossCursor)^^);
    end;

    procedure MCArrowCursor;
    begin
        SetCursor(arrow);
    end;

    procedure MCStartAnimCursor (acurresid: integer);
        var
            acurh: Handle;
            tmplong: longint;
            tmpint: integer;
            ignore: integer;
            i: integer;
    begin
{MCHasColourQD returns true if the machine has }
{Colour Quickdraw, and therefore supports colour}
        gMCCurrHasColour := MCHasColourQD;

        MCcursCursorsOn := true;
        MCcursLastTime := TickCount;
        gMCcurracurid := 0;
        acurh := nil;
        acurh := Get1Resource('acur', acurresid);
        if (acurh = nil) or (ResError <> noErr) then
            exit(MCStartAnimCursor);
        gMCcurracurid := acurresid;
        hlock(acurh);
{Get the number of frames}
        BlockMove(acurh^, @gMCcurscount, 2);
{Get the frame dah dah dah}
        BlockMove(pointer(ord4(acurh^) + 2), @MCcursInterval, 2);
{Get the ids}
        for i := 1 to gMCcurscount do
            begin
                BlockMove(pointer(ord4(acurh^) + 2 + 2 + (4 * (i - 1))), @tmplong, 4);
                gMCacurids[i] := HiWord(tmplong);
            end;
        hunlock(acurh);
        ReleaseResource(acurh);
    end;

    procedure MCNextAnimCursor;
    begin
        if MCcursCursorsOn = false then
            exit(MCNextAnimCursor);
        if TickCount > MCcursLastTime + MCcursInterval then
            begin
                MCcursLastTime := TickCount;
                if gMCcurracurid = 0 then
                    begin
                        MCWatchCursor;
                        exit(MCNextAnimCursor);
                    end;
                if gMCcurrcurindex = gMCcurscount then
                    gMCcurrcurindex := 1
                else
                    gMCcurrcurindex := gMCcurrcurindex + 1;
                MCSetCursor(gMCacurids[gMCcurrcurindex], false); {don't release the cursor}
            end;
    end;

    procedure MCResetAnimCursor;
        var
            curs: CursHandle;
            ccurs: CCrsrHandle;
            i, resid: integer;
    begin
        for i := 1 to kMCCurMaxCursors do
            begin
                resid := gMCacurids[i];
                if gMCCurrHasColour then
                    begin
                        ccurs := GetCCursor(resid);
                        if (ccurs <> nil) and (ResError = noErr) then
                            DisposeCCursor(ccurs);
                    end;
                curs := GetCursor(resid);
                if (curs <> nil) and (ResError = noErr) then
                    ReleaseResource(handle(curs));
                gMCacurids[i] := 0;
            end;
        gMCcurrcurindex := 0;
        gMCcurracurid := 0;
        MCcursCursorsOn := false;
    end;
end.